home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Monster Media 1996 #15
/
Monster Media Number 15 (Monster Media)(July 1996).ISO
/
utils
/
imd110.zip
/
IMD.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1996-04-12
|
10KB
|
350 lines
{$M 5120,0,10240} { 10k reserved for data }
{$N-,E- no math support needed}
{$X- function calls may not be discarded}
{$I- disable I/O checking (trap errors by checking IOResult)}
PROGRAM ImageDirectory;
USES DOS, ImageID, ArcID;
CONST
lf = #13#10;
VAR
dWrap: BOOLEAN;
PROCEDURE showhelp (problem: BYTE);
(* If any *foreseen* errors arise, we are sent here to
give a little help and exit (relatively) peacefully *)
VAR
message: STRING [50];
BEGIN
WriteLn ('IMD v1.04 - Free DOS Image Directory utility.');
WriteLn ('Copyright (c) March 12, 1996, by David Daniel Anderson - Reign Ware.' + lf);
WriteLn ('Usage: IMD [file_spec]' + lf);
WriteLn ('Example: IMD a:\mariah*.jpg' + lf);
WriteLn ('Option: "/R" suppresses line-wrapping of 4DOS/NDOS file descriptions.' + lf);
IF problem > 0 THEN BEGIN
CASE problem OF
1 : message := 'No files matching specification found.';
ELSE message := 'Unanticipated error of unknown type.';
END;
WriteLn ('Error: ' + message);
END;
Halt (problem)
END;
FUNCTION leadingzero (w: WORD): STRING;
VAR
s: STRING;
BEGIN
Str (w: 0, s);
IF (Length (s) = 1) THEN
s := '0' + s;
leadingzero := s;
END;
FUNCTION Comma (li: LONGINT): STRING;
VAR
s: STRING [15];
l: SHORTINT;
BEGIN
Str (li, s);
l := (Length (s) - 2);
WHILE (l > 1) DO BEGIN
Insert (',', s, l);
Dec (l, 3);
END;
Comma := s;
END;
FUNCTION RPad (bstr: STRING; len: BYTE): STRING;
BEGIN
WHILE (Length (bstr) < len) DO
bstr := bstr + #32;
RPad := bstr;
END;
FUNCTION RTrim (InStr: STRING): STRING;
BEGIN
WHILE (Length (InStr) > 0) AND (InStr [Length (InStr)] IN [#0, #9, #32]) DO
Dec (InStr [0]);
RTrim := InStr;
END;
FUNCTION LTrim (InStr: STRING): STRING;
BEGIN
WHILE (Length (InStr) > 0) AND (InStr [1] IN [#0, #9, #32]) DO
Delete (InStr, 1, 1);
LTrim := InStr;
END;
FUNCTION Trim (InStr: STRING): STRING;
BEGIN
Trim := RTrim (LTrim (InStr));
END;
PROCEDURE UpFast (VAR Str: STRING); {** from SWAG **}
INLINE ($8C/$DA/$5E/$1F/$FC/$AC/$30/$E4/$89/$C1/$E3/$12/$BB/Ord('a')/Ord('z')/
$AC/$38/$D8/$72/$08/$38/$F8/$77/$04/$80/$6C/$FF/$20/$E2/$F1/$8E/$DA);
FUNCTION Upper (lstr: STRING): STRING;
BEGIN
upfast (lstr);
Upper := lstr;
END;
FUNCTION IsDir (CONST FileName: PATHSTR): BOOLEAN;
VAR
Attr: WORD;
cFile: FILE;
BEGIN
Assign (cFile, FileName);
GetFAttr (cFile, Attr);
IF (DosError = 0) AND ((Attr AND Directory) = Directory)
THEN IsDir := TRUE
ELSE IsDir := FALSE;
END;
FUNCTION GetFilePath (CONST PSTR: STRING; VAR sDir: DIRSTR): PATHSTR;
VAR
dirinfo : SEARCHREC;
jPath : PATHSTR; { file path, }
jDir : DIRSTR; { directory, }
jName : NAMESTR; { name, }
jExt : EXTSTR; { extension. }
BEGIN
jPath := PSTR;
IF jPath = '' THEN jPath := '*.*';
IF (NOT (jPath [Length (jPath)] IN [':', '\'])) AND IsDir (jPath) THEN
jPath := jPath + '\';
IF (jPath [Length (jPath)] IN [':', '\']) THEN
jPath := jPath + '*.*';
FSplit (FExpand (jPath), jDir, jName, jExt);
jPath := jDir + jName+ jExt;
sDir := jDir;
GetFilePath := jPath;
END;
PROCEDURE writetime (fdatetime: LONGINT);
VAR
DateTimeInf: DATETIME;
BEGIN
UnpackTime (fdatetime, DateTimeInf);
WITH DateTimeInf DO BEGIN
Write
(LeadingZero (Month): 4, '-',
LeadingZero (Day), '-',
Copy (LeadingZero (Year), 3, 2), ' ',
LeadingZero (Hour), ':',
LeadingZero (Min));
(*, ':',
LeadingZero (Sec));
*)
END;
END;
FUNCTION wrapline (theline: STRING): STRING;
{---- Split line after rightmargin character or nearest preceding space ----}
CONST
rightmargin = 40;
hyphen = #45; space = #32; { simple ways of minimizing typing errors }
VAR
parta, partb : STRING; { first and second part of line }
breakchar : STRING [1]; { character which will eventually be a space }
breakfound : BOOLEAN;
breakpos : BYTE;
BEGIN
breakpos := rightmargin + 2;
breakfound := FALSE;
(* Search for a space or a hyphen or the ASCII 255 non-displaying char, *)
(* by decrementing the breakpos while checking validity *)
WHILE ((NOT breakfound) AND (breakpos > 2)) DO
BEGIN
Dec (breakpos);
breakfound := theline [breakpos] IN [space, hyphen, #255];
END;
IF NOT breakfound {if unable to find a valid breakpoint, break at max width}
THEN breakpos := rightmargin + 1;
parta := Copy (theline, 1, breakpos - 1);
partb := Copy (theline, breakpos + 1, Length (theline) - (breakpos));
breakchar := theline [breakpos];
IF NOT (breakchar [1] IN [space, #255]) THEN {save non-blank breakchar}
IF breakpos <= rightmargin
THEN parta := parta + breakchar
ELSE partb := breakchar + partb;
WriteLn (parta); { Write the first part, and return the second part }
wrapline := partb;
END;
FUNCTION WriteDesc (ifile: STRING; VAR IONfile: TEXT): BOOLEAN;
VAR
desc: STRING;
lName: BYTE;
found: BOOLEAN;
ccpos: BYTE;
controlchar: CHAR;
BEGIN
ifile := Upper (ifile);
found := FALSE;
lName := Length (ifile);
Reset (IONfile);
WHILE (NOT found) AND (NOT EoF (IONfile)) DO BEGIN
ReadLn (IONfile, desc);
IF Upper (Copy (desc, 1, lName)) = ifile THEN BEGIN
desc := Copy (desc, lName+2, Length (desc) - (lName+1));
FOR controlchar := #0 TO #31 DO BEGIN
ccpos := Pos (controlchar, desc);
IF ccpos > 0 THEN
desc := Copy (desc, 1, ccpos - 1);
END;
desc := Trim(desc);
IF Length(desc) > 0 THEN BEGIN
found := TRUE;
Write (#32);
IF dWrap THEN BEGIN
WHILE Length (desc) > 40 DO BEGIN
desc := wrapline (desc);
Write ('': 39);
END;
END;
WriteLn (desc);
END;
END;
END;
WriteDesc := found;
END;
FUNCTION IsArchive (fName: PATHSTR): STRING;
VAR
FileID : ARCTYPE;
AID : STRING;
BEGIN
FileID := IsArc (fName);
CASE FileID OF
NONE : AID := '';
ACB : AID := '[ACB archive]';
AIN : AID := '[AIN archive]';
ARC : AID := '[ARC archive]';
ARJ : AID := '[ARJ archive]';
HA : AID := '[HA archive]';
HAP : AID := '[HAP archive]';
HPK : AID := '[HPACK archive]';
HYP : AID := '[HYPER archive]';
JRC : AID := '[JRchive archive]';
LZH : AID := '[LHA archive]';
LZS : AID := '[LARC archive]';
LIB : AID := '[CODEC archive]';
LIM : AID := '[LIMIT archive]';
PAK : AID := '[PAK archive]';
PAQ : AID := '[PAQ archive]';
PUT : AID := '[PUT archive]';
RAR : AID := '[RAR archive]';
SAR : AID := '[SAR archive]';
SQZ : AID := '[SQZ archive]';
UC2 : AID := '[UC archive]';
YC : AID := '[YAC archive]';
ZIP : AID := '[ZIP archive]';
ZOO : AID := '[ZOO archive]'
ELSE AID := 'Woops!';
END;
IsArchive := AID;
END;
(*****************************************************************************)
VAR
iName,
gPath: STRING;
gdir: DIRSTR;
dirinfo,
IONinfo: SEARCHREC;
numfiles: WORD;
sizefiles: LONGINT;
iType: STRING;
iWidth, iHeight: LONGINT;
iColors, GIFLite: STRING;
ION,
DESCRIPTION: BOOLEAN;
IONfile: TEXT;
ptStr: STRING;
Param,
fParm: BYTE;
BEGIN
FileMode := 0;
numfiles := 0;
sizefiles := 0;
fParm := 1;
dWrap := TRUE;
IF (ParamCount > 0) THEN BEGIN
FOR Param := 1 to ParamCount DO BEGIN
ptStr := ParamStr(Param);
IF (Length(ptStr) = 2) AND (ptStr[1] IN ['-','/'])
AND (ptStr[2] in ['r','R']) THEN BEGIN
dWrap := FALSE;
IF Param = 1 THEN fParm := 2;
END;
END;
END;
gPath := GetFilePath (ParamStr (fParm), gDir);
FindFirst (gPath, ReadOnly + Hidden + Archive, dirinfo);
IF (DosError <> 0) THEN showhelp (1);
DESCRIPTION := FALSE;
FindFirst (gDir + 'descript.ion', ReadOnly + Hidden + Archive, IONinfo);
IF (DosError = 0) THEN BEGIN
DESCRIPTION := TRUE;
Assign (IONfile, gDir + IONinfo. Name);
END;
WriteLn ('Directory of: ' + gPath + lf);
DosError := 0;
WHILE (DosError = 0) DO BEGIN
IF (Upper (dirinfo. Name) <> 'DESCRIPT.ION') THEN BEGIN
iName := gdir + dirinfo. Name;
Write ((RPad (dirinfo. Name, 12)), dirinfo. Size : 9);
Inc (numfiles);
Inc (sizefiles, dirinfo. Size);
writetime (dirinfo. Time);
ION := FALSE;
IF DESCRIPTION THEN
ION := WriteDesc (dirinfo. Name, IONfile);
IF (dirinfo. Size > 0)
THEN iType := IsImage (iName, iWidth, iHeight, iColors, GIFLite)
ELSE iType := '';
IF (iType <> '')
THEN BEGIN
IF ION THEN Write ('': 38); { Set up for file ID }
WriteLn (#32, RPad (iType, 6), ' [': 2, iWidth: 4, iHeight: 5, iColors: 7, #32#32, GIFLite: 6)
END
ELSE BEGIN
IF (dirinfo. Size > 0)
THEN iType := IsArchive (gdir+dirinfo.Name);
IF (iType <> '')
THEN BEGIN
IF ION THEN Write ('': 38); { Set up for file ID }
WriteLn (#32, iType);
END
ELSE
WriteLn;
END;
END;
FindNext (dirinfo);
END;
WriteLn (comma (sizefiles): 12, ' bytes in ', numfiles, ' file(s)');
WriteLn;
IF DESCRIPTION THEN Close (IONfile);
END.